home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / prec / prec-parse.scm next >
Encoding:
Text File  |  1994-09-27  |  8.1 KB  |  261 lines  |  [TEXT/CCL2]
  1. ;;; prec-parse.scm -- do precedence parsing of expressions and patterns
  2. ;;;
  3. ;;; author :  John & Sandra
  4. ;;; date   :  04 Feb 1992
  5. ;;;
  6. ;;;
  7.  
  8.  
  9. ;;; ==================================================================
  10. ;;; Handling for pp-exp-list
  11. ;;; ==================================================================
  12.  
  13. ;;; This function is called during the scope phase after all of the
  14. ;;; exps in a pp-exp-list have already been walked.  Basically, the
  15. ;;; purpose is to turn the original pp-exp-list into something else.
  16. ;;; Look for the section cases first and treat them specially.
  17.  
  18. ;;; Sections are handled by inserting a magic cookie (void) into the
  19. ;;; list where the `missing' operand of the section would be and then
  20. ;;; making sure the cookie stays at the top.
  21.  
  22. ;;; Unary minus needs checking to avoid things like a*-a.
  23.  
  24. (define (massage-pp-exp-list exps)
  25.  (let* ((first-term (car exps))
  26.         (last-term (car (last exps)))
  27.         (type (cond ((infix-var-or-con? first-term) 'section-l)
  28.             ((infix-var-or-con? last-term) 'section-r)
  29.             (else 'exp)))
  30.     (exps1 (cond ((eq? type 'section-l)
  31.               (cons (make void) exps))
  32.              ((eq? type 'section-r)
  33.               (append exps (list (make void))))
  34.              (else exps)))
  35.     (parsed-exp (parse-pp-list '#f exps1)))
  36.    (if (eq? type 'exp)
  37.        parsed-exp
  38.        (if (or (not (app? parsed-exp))
  39.            (not (app? (app-fn parsed-exp))))
  40.        (begin
  41.          (signal-section-precedence-conflict
  42.           (if (eq? type 'section-l) first-term last-term))
  43.          (make void))
  44.        (let ((rhs (app-arg parsed-exp))
  45.          (op (app-fn (app-fn parsed-exp)))
  46.          (lhs (app-arg (app-fn parsed-exp))))
  47.          (if (eq? type 'section-l)
  48.          (if (void? lhs)
  49.              (make section-l (op op) (exp rhs))
  50.              (begin
  51.                (signal-section-precedence-conflict first-term)
  52.                (make void)))
  53.          (if (void? rhs)
  54.              (make section-r (op op) (exp lhs))
  55.              (begin
  56.                (signal-section-precedence-conflict last-term)
  57.                (make void)))))))))
  58.  
  59.  
  60. ;;; ==================================================================
  61. ;;; Handling for pp-pat-list
  62. ;;; ==================================================================
  63.  
  64. ;;; In this case, we have to do an explicit walk of the pattern looking
  65. ;;; at all of its subpatterns.
  66. ;;;  ** This is a crock - the scope walker needs fixing.
  67.  
  68. (define (massage-pattern pat)
  69.   (cond ((is-type? 'as-pat pat)
  70.      (setf (as-pat-pattern pat) (massage-pattern (as-pat-pattern pat)))
  71.      pat)
  72.     ((is-type? 'irr-pat pat)
  73.      (setf (irr-pat-pattern pat) (massage-pattern (irr-pat-pattern pat)))
  74.      pat)
  75.     ((is-type? 'plus-pat pat)
  76.      (setf (plus-pat-pattern pat) (massage-pattern (plus-pat-pattern pat)))
  77.      pat)
  78.     ((is-type? 'pcon pat)
  79.      (when (eq? (pcon-con pat) *undefined-def*)
  80.        (setf (pcon-con pat) (lookup-toplevel-name (pcon-name pat))))
  81.      (setf (pcon-pats pat) (massage-pattern-list (pcon-pats pat)))
  82.      pat)
  83.     ((is-type? 'list-pat pat)
  84.      (setf (list-pat-pats pat) (massage-pattern-list (list-pat-pats pat)))
  85.      pat)
  86.     ((is-type? 'pp-pat-list pat)
  87.      (parse-pp-list '#t (massage-pattern-list (pp-pat-list-pats pat))))
  88.     ((is-type? 'dynamic-pat pat)
  89.      (setf (dynamic-pat-pat pat) (massage-pattern (dynamic-pat-pat pat)))
  90.      (resolve-signature (dynamic-pat-sig pat))
  91.      pat)
  92.     (else
  93.      pat)))
  94.  
  95. (define (massage-pattern-list pats)
  96.   (map (function massage-pattern) pats))
  97.  
  98.  
  99. ;;; ==================================================================
  100. ;;; Shared support
  101. ;;; ==================================================================
  102.  
  103. ;;; This is the main routine.
  104.  
  105. (define (parse-pp-list pattern? l)
  106.   (mlet (((stack terms) (push-pp-stack '() l)))
  107.     (pp-parse-next-term pattern? stack terms)))
  108.  
  109. (define (pp-parse-next-term pattern? stack terms)
  110.   (if (null? terms)
  111.       (reduce-complete-stack pattern? stack)
  112.       (let ((stack (reduce-stronger-ops pattern? stack (car terms))))
  113.     (mlet (((stack terms)
  114.         (push-pp-stack (cons (car terms) stack) (cdr terms))))
  115.        (pp-parse-next-term pattern? stack terms)))))
  116.  
  117. (define (reduce-complete-stack pattern? stack)
  118.   (if (pp-stack-op-empty? stack)
  119.       (car stack)
  120.       (reduce-complete-stack pattern? (reduce-pp-stack pattern? stack))))
  121.  
  122. (define (reduce-pp-stack pattern? stack)
  123.   (let ((term (car stack))
  124.     (op (cadr stack)))
  125.     (if pattern?
  126.     (cond ((pp-pat-plus? op)
  127.            (let ((lhs (caddr stack)))
  128.          (cond ((or (not (const-pat? term))
  129.                 (and (not (var-pat? lhs))
  130.                  (not (wildcard-pat? lhs))))
  131.             (signal-plus-precedence-conflict term)
  132.             (cddr stack))
  133.                (else
  134.             (cons (make plus-pat (pattern lhs)
  135.                              (k (integer-const-value
  136.                          (const-pat-value term))))
  137.                   (cdddr stack))))))
  138.           ((pp-pat-negated? op)
  139.            (cond ((const-pat? term)
  140.               (let ((v (const-pat-value term)))
  141.             (if (integer-const? v)
  142.                 (setf (integer-const-value v)
  143.                   (- (integer-const-value v)))
  144.                 (setf (float-const-numerator v)
  145.                   (- (float-const-numerator v)))))
  146.               (cons term (cddr stack)))
  147.              (else
  148.               (signal-minus-precedence-conflict term)
  149.               (cons term (cddr stack)))))
  150.           (else
  151.            (setf (pcon-pats op) (list (caddr stack) term))
  152.            (cons op (cdddr stack))))
  153.     (cond ((negate? op)
  154.            (cons (**app (**var/def (core-symbol "negate")) term)
  155.              (cddr stack)))
  156.           (else
  157.            (cons (**app op (caddr stack) term) (cdddr stack)))))))
  158.  
  159. (define (pp-stack-op-empty? stack)
  160.   (null? (cdr stack)))
  161.  
  162. (define (top-stack-op stack)
  163.   (cadr stack))
  164.  
  165. ;;; %%% This does not pick up -5*2 as an error.  Too bad!
  166.  
  167.  
  168. (define (push-pp-stack stack terms)
  169.   (let ((term (car terms)))
  170.     (if (or (negate? term) (pp-pat-negated? term))
  171.     (begin
  172.       (when (and stack (stronger-op? (car stack) term))
  173.           (unary-minus-prec-conflict (car stack)))
  174.       (push-pp-stack (cons term stack) (cdr terms)))
  175.     (values (cons term stack) (cdr terms)))))
  176.  
  177. (define (reduce-stronger-ops pattern? stack op)
  178.   (cond ((pp-stack-op-empty? stack) stack)
  179.     ((stronger-op? (top-stack-op stack) op)
  180.      (reduce-stronger-ops pattern? (reduce-pp-stack pattern? stack) op))
  181.     (else stack)))
  182.  
  183. (define (stronger-op? op1 op2)
  184.   (let ((fixity1 (get-op-fixity op1))
  185.     (fixity2 (get-op-fixity op2)))
  186.     (cond ((> (fixity-precedence fixity1) (fixity-precedence fixity2))
  187.        '#t)
  188.       ((< (fixity-precedence fixity1) (fixity-precedence fixity2))
  189.        '#f)
  190.       (else
  191.        (let ((a1 (fixity-associativity fixity1))
  192.          (a2 (fixity-associativity fixity2)))
  193.          (if (eq? a1 a2)
  194.          (cond ((eq? a1 'l)
  195.             '#t)
  196.                ((eq? a1 'r)
  197.             '#f)
  198.                (else
  199.             (signal-precedence-conflict op1 op2)
  200.             '#t))
  201.          (begin
  202.            (signal-precedence-conflict op1 op2)
  203.            '#t))))
  204.       )))
  205.          
  206. (define (get-op-fixity op)
  207.   (cond ((var-ref? op)
  208.      (pp-get-var-fixity (var-ref-var op)))
  209.     ((con-ref? op)
  210.      (pp-get-con-fixity (con-ref-con op)))
  211.     ((pcon? op)
  212.      (pp-get-con-fixity (pcon-con op)))
  213.     ((or (negate? op) (pp-pat-negated? op))
  214.      (pp-get-var-fixity (core-symbol "-")))
  215.     ((pp-pat-plus? op)
  216.      (pp-get-var-fixity (core-symbol "+")))
  217.     (else
  218.      (error "Bad op ~s in pp-parse." op))))
  219.  
  220. (define (pp-get-var-fixity def)
  221.   (if (eq? (var-fixity def) '#f)
  222.       default-fixity
  223.       (var-fixity def)))
  224.  
  225. (define (pp-get-con-fixity def)
  226.   (if (eq? (con-fixity def) '#f)
  227.       default-fixity
  228.       (con-fixity def)))
  229.  
  230. ;;; Error handlers
  231.  
  232. (define (signal-section-precedence-conflict op)
  233.   (phase-error 'section-precedence-conflict
  234.     "Operators in section body have lower precedence than section operator ~A."
  235.    op))
  236.  
  237. (define (signal-precedence-conflict op1 op2)
  238.   (phase-error 'precedence-conflict
  239.     "The operators ~s and ~s appear consecutively, but they have the same~%~
  240.      precedence and are not either both left or both right associative.~%~
  241.      You must add parentheses to avoid a precedence conflict."
  242.     op1 op2))
  243.  
  244. (define (signal-plus-precedence-conflict term)
  245.   (phase-error 'plus-precedence-conflict
  246.     "You need to put parentheses around the plus-pattern ~a~%~
  247.      to avoid a precedence conflict."
  248.     term))
  249.  
  250. (define (signal-minus-precedence-conflict arg)
  251.   (phase-error 'minus-precedence-conflict
  252.     "You need to put parentheses around the negative literal ~a~%~
  253.      to avoid a precedence conflict."
  254.     arg))
  255.  
  256. (define (unary-minus-prec-conflict arg)
  257.   (recoverable-error 'minus-precedence-conflict
  258.      "Operator ~A too strong for unary minus; extra parens are required~%"
  259.      arg))
  260.  
  261.